home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / pibt32s1.arc / DOCOMPUS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-08-27  |  31.8 KB  |  1,027 lines
  1. (*----------------------------------------------------------------------*)
  2. (*    Do_CompuServe_B_Transfer --- Do Compuserve B Protocol transfer    *)
  3. (*----------------------------------------------------------------------*)
  4.  
  5. OVERLAY FUNCTION Do_CompuServe_B_Transfer : BOOLEAN;
  6.  
  7. (*----------------------------------------------------------------------*)
  8. (*                                                                      *)
  9. (*     Routine:  Do_CompuServe_B_Transfer                               *)
  10. (*                                                                      *)
  11. (*     Purpose:  Executes CompuServe B protocol transfers               *)
  12. (*                                                                      *)
  13. (*     Calling Sequence:                                                *)
  14. (*                                                                      *)
  15. (*        OK := Do_CompuServe_B_Transfer : BOOLEAN;                     *)
  16. (*                                                                      *)
  17. (*           OK   --- set TRUE if transfer went OK                      *)
  18. (*                                                                      *)
  19. (*     Calls:  None                                                     *)
  20. (*                                                                      *)
  21. (*     Called by:  Emulate_VT52                                         *)
  22. (*                 Emulate_ANSI                                         *)
  23. (*                                                                      *)
  24. (*     Remarks:                                                         *)
  25. (*                                                                      *)
  26. (*        This code is taken from some prepared by Jim Nutt.            *)
  27. (*                                                                      *)
  28. (*----------------------------------------------------------------------*)
  29.  
  30. CONST
  31.    Xmt_Size     = 511;
  32.    Rcv_Size     = 512;
  33.    Max_Errors   =  10;
  34.  
  35.                    (* Sender Actions *)
  36.  
  37.    S_Send_packet  = 0;
  38.    S_Get_DLE      = 1;
  39.    S_Get_num      = 2;
  40.    S_Get_seq      = 3;
  41.    S_Get_data     = 4;
  42.    S_Get_CheckSum = 5;
  43.    S_Timed_Out    = 6;
  44.    S_Send_NAK     = 7;
  45.  
  46.                    (* Receiver Actions *)
  47.  
  48.    R_Get_DLE      = 0;
  49.    R_Get_b        = 1;
  50.    R_Get_seq      = 2;
  51.    R_Get_data     = 3;
  52.    R_Get_CheckSum = 4;
  53.    R_Send_NAK     = 5;
  54.    R_Send_ACK     = 6;
  55.  
  56.                    (* Other Constants *)
  57.  
  58.    xmt_col = 50;
  59.    rcv_col = 36;
  60.    xon     = 17;
  61.    xoff    = 19;
  62.    dle     = 16;
  63.    etx     = 03;
  64.    nak     = 21;
  65.    ENQ     = 05;
  66.    wack    = 59;
  67.  
  68.    Err_Mess_Line = 5               (* Line for status report *);
  69.  
  70. TYPE
  71.    BufferType = ARRAY[0..520] OF BYTE;
  72.  
  73. VAR
  74.    Timer      : INTEGER;
  75.    R_Size     : INTEGER            (* size of receiver buffer *);
  76.    CheckSum   : INTEGER;
  77.    Seq_Num    : INTEGER;
  78.    Ch         : INTEGER;           (* current character *)
  79.  
  80.    Xoff_Flag  : BOOLEAN;
  81.    Timed_Out  : BOOLEAN            (* we timed out before receiving character *);
  82.    Masked     : BOOLEAN;           (* TRUE if ctrl character was 'Masked' *)
  83.  
  84.    S_Buffer   : BufferType;
  85.    R_Buffer   : BufferType;
  86.    FileName   : AnyStr             (* PathName *);
  87.    i          : INTEGER;
  88.    n          : INTEGER;
  89.    Dummy      : BOOLEAN;
  90.  
  91.    Comp_Title    : AnyStr;
  92.    Total_Blocks  : INTEGER        (* Blocks processed so far *);
  93.    Total_Packets : INTEGER        (* Packets thus far        *);
  94.    Total_Errors  : INTEGER        (* Errors thus far         *);
  95.  
  96.    Halt_Transfer : BOOLEAN        (* Keypressed to halt transfer *);
  97.  
  98. (*----------------------------------------------------------------------*)
  99.  
  100. PROCEDURE Update_B_Display;
  101.  
  102. BEGIN (* Update_B_Display *)
  103.  
  104.    GoToXY( 22 , 1 );
  105.    WRITE( Total_Blocks );
  106.    ClrEol;
  107.  
  108.    GoToXY( 22 , 2 );
  109.    WRITE( Total_Packets );
  110.    ClrEol;
  111.  
  112.    GoToXY( 22 , 3 );
  113.    WRITE( Total_Errors );
  114.    ClrEol;
  115.  
  116. END   (* Update_B_Display *);
  117.  
  118. (*----------------------------------------------------------------------*)
  119.  
  120. PROCEDURE Check_Keyboard;
  121.  
  122. VAR
  123.    Ch: CHAR;
  124.  
  125. BEGIN (* Check_Keyboard *)
  126.  
  127.    IF KeyPressed THEN
  128.       BEGIN
  129.  
  130.          READ( Kbd, Ch );
  131.  
  132.          Halt_Transfer := Halt_Transfer OR ( Ch = CHR( ESC ) );
  133.  
  134.          IF ( ( Ch = CHR( ESC ) ) AND KeyPressed ) THEN
  135.             READ( Kbd, Ch );
  136.  
  137.       END;
  138.  
  139. END   (* Check_Keyboard *);
  140.  
  141. (*----------------------------------------------------------------------*)
  142.  
  143. PROCEDURE Send_Masked_Byte( Ch : INTEGER );
  144.  
  145. BEGIN (* Send_Masked_Byte *)
  146.  
  147.    IF ( Ch < 32 ) THEN
  148.       BEGIN
  149.          Async_Send( CHR( DLE ) );
  150.          Async_Send( CHR( Ch + ORD('@') ) );
  151.       END
  152.    ELSE
  153.       Async_Send( CHR( Ch ) );
  154.  
  155. END   (* Send_Masked_Byte *);
  156.  
  157. (*----------------------------------------------------------------------*)
  158.  
  159. PROCEDURE Send_ACK;
  160.  
  161. BEGIN (* Send_ACK *)
  162.  
  163.    Async_Send( CHR( DLE ) );
  164.    Async_Send( CHR( Seq_Num + ORD('0') ) );
  165.  
  166.    Update_B_Display;
  167.  
  168. END   (* Send_ACK *);
  169.  
  170. (*----------------------------------------------------------------------*)
  171.  
  172. PROCEDURE Send_NAK;
  173.  
  174. BEGIN (* Send_NAK *)
  175.  
  176.    GoToXY( 22 , Err_Mess_Line );
  177.    WRITE('Sending NAK for block ', Total_Blocks );
  178.    ClrEol;
  179.  
  180.    Async_Send( CHR( NAK ) );
  181.  
  182.    Update_B_Display;
  183.  
  184. END   (* Send_NAK *);
  185.  
  186. (*----------------------------------------------------------------------*)
  187.  
  188. PROCEDURE Send_ENQ;
  189.  
  190. BEGIN (* Send_ENQ *)
  191.  
  192.    Async_Send( CHR( ENQ ) );
  193.  
  194. END   (* Send_ENQ *);
  195.  
  196. (*----------------------------------------------------------------------*)
  197.  
  198. FUNCTION Read_Byte : BOOLEAN;
  199.  
  200. BEGIN (* Read_Byte *)
  201.  
  202.    Timed_Out := FALSE;
  203.  
  204.    Async_Receive_With_Timeout( Timer , Ch );
  205.  
  206.    IF ( Ch = TimeOut ) THEN
  207.       BEGIN
  208.          Read_Byte := FALSE;
  209.          EXIT;
  210.       END;
  211.  
  212.    Read_Byte := TRUE;
  213.  
  214. END   (* Read_Byte *);
  215.  
  216. (*----------------------------------------------------------------------*)
  217.  
  218. FUNCTION Read_Masked_Byte : BOOLEAN;
  219.  
  220. BEGIN (* Read_Masked_Byte *)
  221.  
  222.    Masked := FALSE;
  223.  
  224.    IF  NOT Read_Byte THEN
  225.       BEGIN
  226.          Read_Masked_Byte := FALSE;
  227.          EXIT;
  228.       END;
  229.  
  230.    IF ( Ch = DLE ) THEN
  231.      BEGIN
  232.  
  233.          IF NOT Read_Byte THEN
  234.             BEGIN
  235.                Read_Masked_Byte := FALSE;
  236.                EXIT;
  237.             END;
  238.  
  239.          Ch := Ch AND $1F;
  240.  
  241.          Masked := TRUE;
  242.  
  243.       END;
  244.  
  245.    Read_Masked_Byte := TRUE;
  246.  
  247. END   (* Read_Masked_Byte *);
  248.  
  249. (*----------------------------------------------------------------------*)
  250.  
  251. PROCEDURE Do_CheckSum( Ch : INTEGER );
  252.  
  253. BEGIN (* Do_CheckSum *)
  254.  
  255.    CheckSum := CheckSum SHL 1;
  256.  
  257.    IF ( CheckSum > 255 ) THEN
  258.       CheckSum := ( CheckSum AND $FF ) + 1;
  259.  
  260.    CheckSum := CheckSum + Ch;
  261.  
  262.    IF ( CheckSum > 255 ) THEN
  263.       CheckSum := ( CheckSum AND $FF ) + 1;
  264.  
  265. END   (* Do_CheckSum *);
  266.  
  267. (*----------------------------------------------------------------------*)
  268.  
  269. FUNCTION Send_Packet( size: INTEGER ) : BOOLEAN;
  270.  
  271. VAR
  272.    Action     : INTEGER;
  273.    Errors     : INTEGER;
  274.    Next_Seq   : INTEGER;
  275.    Block_Num  : INTEGER;
  276.    i          : INTEGER;
  277.    Sent_ENQ   : BOOLEAN;
  278.    Quit_Send  : BOOLEAN;
  279.  
  280. BEGIN (* Send_Packet *)
  281.  
  282.    Send_Packet   := FALSE;
  283.    Quit_Send     := FALSE;
  284.  
  285.    Next_Seq      := ( Seq_Num + 1 ) MOD 10;
  286.  
  287.    Total_Packets := Total_Packets + 1;
  288.  
  289.    Errors        := 0;
  290.  
  291.    Sent_ENQ      := FALSE;
  292.  
  293.    Action        := S_Send_Packet;
  294.  
  295.    WHILE ( NOT ( Quit_Send OR Halt_Transfer ) ) DO
  296.       BEGIN
  297.  
  298.          Check_KeyBoard;
  299.  
  300.          CASE Action OF
  301.             S_Send_Packet:  BEGIN
  302.  
  303.                                CheckSum := 0;
  304.  
  305.                                Async_Send( CHR( DLE ) );
  306.                                Async_Send( 'B' );
  307.                                Async_Send( CHR( Next_Seq + ORD('0') ) );
  308.  
  309.                                Do_Checksum( Next_Seq + ORD('0') );
  310.  
  311.                                FOR i := 0 TO Size DO
  312.                                   BEGIN
  313.                                      Send_Masked_Byte( S_Buffer[i] );
  314.                                      Do_Checksum     ( S_Buffer[i] );
  315.                                   END;
  316.  
  317.                                Async_Send( CHR( ETX ) );
  318.  
  319.                                Do_Checksum( ETX );
  320.  
  321.                                Send_Masked_Byte( CheckSum );
  322.  
  323.                                Action := S_Get_DLE;
  324.  
  325.                             END;
  326.  
  327.            S_Get_DLE:       BEGIN
  328.  
  329.                                Timer := 30;
  330.  
  331.                                IF NOT Read_Byte THEN
  332.                                   Action := S_Timed_Out
  333.                                ELSE IF ( Ch = DLE ) THEN
  334.                                   Action := S_Get_num
  335.                                ELSE IF ( Ch = NAK ) THEN
  336.                                   BEGIN
  337.                                      Errors       := Errors + 1;
  338.                                      Total_Errors := Total_Errors + 1;
  339.                                      IF ( Errors > Max_Errors ) THEN
  340.                                         BEGIN
  341.                                            Send_Packet := FALSE;
  342.                                            Quit_Send   := TRUE;
  343.                                         END
  344.                                      ELSE
  345.                                         Action := S_Send_Packet;
  346.                                   END
  347.                                ELSE IF ( Ch = ETX ) THEN
  348.                                   Action := S_Send_NAK;
  349.  
  350.                             END;
  351.  
  352.            S_Get_num:       BEGIN
  353.  
  354.                                Timer := 30;
  355.  
  356.                                IF NOT Read_Byte THEN
  357.                                   Action := S_Timed_Out
  358.                                ELSE IF ( Ch >= ORD('0') ) AND ( Ch <= ORD('9') ) THEN
  359.                                   BEGIN
  360.  
  361.                                      IF ( ( Ch - ORD('0') ) = Seq_Num ) THEN
  362.                                         IF Sent_ENQ THEN
  363.                                            Action := S_Send_Packet
  364.                                         ELSE Action := S_Get_DLE
  365.                                      ELSE
  366.                                         IF ( ( Ch - ORD('0') ) = Next_Seq ) THEN
  367.                                            BEGIN
  368.                                               Seq_Num     := Next_Seq;
  369.                                               Send_Packet := TRUE;
  370.                                               Quit_Send   := TRUE;
  371.                                            END
  372.                                         ELSE
  373.                                            IF ( Errors = 0 ) THEN
  374.                                               Action := S_Send_Packet
  375.                                            ELSE
  376.                                               Action := S_Get_DLE;
  377.  
  378.                                   END
  379.                                ELSE IF ( Ch = nak ) THEN
  380.                                   Action := S_Send_Packet
  381.                                ELSE IF ( Ch = wack ) THEN
  382.                                   BEGIN
  383.                                      Timer  := Timer + 10;
  384.                                      Action := S_Get_DLE;
  385.                                   END
  386.                                ELSE IF ( Ch = ORD('B') ) THEN
  387.                                   Action := S_Get_seq
  388.                                ELSE IF ( Ch = etx ) THEN
  389.                                   Action := S_Send_NAK
  390.                                ELSE
  391.                                   Action := S_Get_DLE;
  392.  
  393.                             END;
  394.  
  395.            S_Get_seq:       BEGIN
  396.  
  397.                                Timer := 10;
  398.  
  399.                                IF NOT Read_Byte THEN
  400.                                   Action := S_Send_NAK
  401.                                ELSE
  402.                                   BEGIN
  403.  
  404.                                      CheckSum  := 0;
  405.  
  406.                                      Block_Num := Ch - ORD('0');
  407.  
  408.                                      Do_Checksum( Ch );
  409.  
  410.                                      i := 0;
  411.  
  412.                                      Action := S_Get_data;
  413.  
  414.                                   END;
  415.  
  416.                             END;
  417.  
  418.            S_Get_data:      BEGIN
  419.  
  420.                                Timer := 10;
  421.  
  422.                                IF NOT Read_Masked_Byte THEN
  423.                                   Action := S_Send_NAK
  424.                                ELSE IF ( ( Ch = etx ) AND ( NOT Masked ) ) THEN
  425.                                   BEGIN
  426.                                      Do_Checksum( ETX );
  427.                                      Action := S_Get_CheckSum;
  428.                                   END
  429.                                ELSE
  430.                                   BEGIN
  431.                                      R_Buffer[i] := Ch;
  432.                                      i           := i + 1;
  433.                                      Do_Checksum( Ch );
  434.                                   END;
  435.  
  436.                             END;
  437.  
  438.            S_Get_CheckSum:  BEGIN
  439.  
  440.                                Timer := 10;
  441.  
  442.                                IF ( NOT Read_Masked_Byte ) THEN
  443.                                   Action := S_Send_NAK
  444.                                ELSE IF ( Ch <> CheckSum ) THEN
  445.                                   Action := S_Send_NAK
  446.                                ELSE IF ( Block_Num <>
  447.                                          ( ( Next_Seq + 1 ) mod 10 ) ) THEN
  448.                                   Action := S_Send_NAK
  449.                                ELSE
  450.                                   BEGIN
  451.                                      Seq_Num     := Block_Num;
  452.                                      Send_ACK;
  453.                                      R_Size      := i;
  454.                                      Send_Packet := TRUE;
  455.                                      Quit_Send   := TRUE;
  456.                                   END;
  457.  
  458.                             END;
  459.  
  460.            S_Timed_Out:     BEGIN
  461.  
  462.                                Errors       := Errors + 1;
  463.                                Total_Errors := Total_Errors + 1;
  464.  
  465.                                IF ( Errors > 4 ) THEN
  466.                                   BEGIN
  467.                                      Send_Packet := FALSE;
  468.                                      Quit_Send   := TRUE;
  469.                                   END;
  470.  
  471.                                Action := S_Get_DLE;
  472.  
  473.                             END;
  474.  
  475.            S_Send_NAK:      BEGIN
  476.  
  477.                                Errors       := Errors + 1;
  478.                                Total_Errors := Total_Errors + 1;
  479.  
  480.                                IF ( Errors > Max_Errors ) THEN
  481.                                   BEGIN
  482.                                      Send_Packet := FALSE;
  483.                                      Quit_Send   := TRUE;
  484.                                   END;
  485.  
  486.                                Send_NAK;
  487.  
  488.                                Action := S_Get_DLE;
  489.  
  490.                             END;
  491.  
  492.          END (* CASE *);
  493.  
  494.          Update_B_Display;
  495.  
  496.       END (* BEGIN *);
  497.  
  498. END    (* Send_Packet *);
  499.  
  500. (*----------------------------------------------------------------------*)
  501.  
  502. PROCEDURE Send_Failure( Code : CHAR );
  503.  
  504. VAR
  505.    Dummy : BOOLEAN;
  506.  
  507. BEGIN (* Send_Failure *)
  508.  
  509.    S_Buffer[0] := ORD( 'F'  );
  510.    S_Buffer[1] := ORD( Code );
  511.  
  512.    Dummy := Send_Packet( 2 );
  513.  
  514. END   (* Send_Failure *);
  515.  
  516. (*----------------------------------------------------------------------*)
  517.  
  518. FUNCTION Read_File( VAR Data_File : INTEGER;
  519.                     VAR S_Buffer  : BufferType;
  520.                     n             : INTEGER;
  521.                     Xmt_Size      : INTEGER ) : INTEGER;
  522.  
  523. VAR
  524.    I : INTEGER;
  525.    L : INTEGER;
  526.  
  527. BEGIN (* Read_File *)
  528.  
  529.    L := Xmt_Size;
  530.  
  531.    I := Read_File_Handle( Data_File, S_Buffer[n], L );
  532.  
  533.    Read_File := L;
  534.  
  535. END    (* Read_File *);
  536.  
  537. (*----------------------------------------------------------------------*)
  538.  
  539. FUNCTION Send_File( Name : AnyStr ) : BOOLEAN;
  540.  
  541. VAR
  542.    n         : INTEGER;
  543.    Data_File : INTEGER;
  544.    IO_Error  : INTEGER;
  545.  
  546. BEGIN (* Send_File *)
  547.                                    (* Assume send fails        *)
  548.    Send_File := FALSE;
  549.                                    (* Open file to be uploaded *)
  550.  
  551.    IO_Error := Open_File_Handle( Name , Access_Read_Mode , Data_File );
  552.  
  553.                                    (* If file can't be opened, halt *)
  554.                                    (* transfer.                     *)
  555.    IF ( IO_Error <> 0 ) THEN
  556.       BEGIN
  557.          Send_Failure('E');
  558.          GoToXY( 22 , Err_Mess_Line );
  559.          WRITE('Can''t open file to be sent, transfer stopped.');
  560.          ClrEol;
  561.          EXIT;
  562.       END;
  563.  
  564.    REPEAT
  565.                                    (* Read next sector of data *)
  566.       S_Buffer[0] := ORD('N');
  567.       n           := Read_File( Data_File, S_Buffer, 1, Xmt_Size );
  568.  
  569.                                    (* Send data packet if anything *)
  570.                                    (* to send.                     *)
  571.       IF ( n > 0 ) THEN
  572.          BEGIN
  573.                                    (* If packet not sent, report *)
  574.                                    (* failure.                   *)
  575.  
  576.             Total_Blocks := Total_Blocks + 1;
  577.  
  578.             IF ( NOT Send_Packet( n ) ) THEN
  579.                BEGIN
  580.                   GoToXY( 22 , Err_Mess_Line );
  581.                   WRITE('Can''t send packet, transfer stopped.');
  582.                   ClrEol;
  583.                   Halt_Transfer := TRUE;
  584.                END;
  585.  
  586.          END;
  587.                                    (* Check for keyboard input halting *)
  588.                                    (* transfer.                        *)
  589.  
  590.       Check_Keyboard;
  591.  
  592.       IF Halt_Transfer THEN
  593.          BEGIN
  594.             Send_Failure('E');
  595.             GoToXY( 22 , Err_Mess_Line );
  596.             WRITE('ESC key hit -- transfer terminated.');
  597.             ClrEol;
  598.          END;
  599.  
  600.       Update_B_Display;
  601.  
  602.    UNTIL ( n <= 0 ) OR Halt_Transfer;
  603.  
  604.                                    (* Close file *)
  605.  
  606.    IO_Error  := Close_File_Handle( Data_File );
  607.  
  608.    IF ( NOT Halt_Transfer ) THEN
  609.       BEGIN
  610.                                    (* Send end of file packet. *)
  611.          S_Buffer[0] := ORD('T');
  612.          S_Buffer[1] := ORD('C');
  613.  
  614.          IF ( NOT Send_Packet( 2 ) ) THEN
  615.             BEGIN
  616.                GoToXY( 22 , Err_Mess_Line );
  617.                WRITE('Can''t send end of file packet, transfer stopped.');
  618.                ClrEol;
  619.             END
  620.          ELSE
  621.             Send_File := TRUE;
  622.  
  623.       END;
  624.  
  625. END    (* Send_File *);
  626.  
  627. (*----------------------------------------------------------------------*)
  628.  
  629. FUNCTION Read_Packet : BOOLEAN;
  630.  
  631. (* True if packet is available from host *)
  632.  
  633. VAR
  634.    Action     : INTEGER;
  635.    Next_Seq   : INTEGER;
  636.    Block_Num  : INTEGER;
  637.    Errors     : INTEGER;
  638.    i          : INTEGER;
  639.  
  640. BEGIN (* Read_Packet *)
  641.  
  642.                                    (* Clear out packet area *)
  643.    FillChar( R_Buffer , 520 , 0 );
  644.  
  645.                                    (* Packet sequence number *)
  646.  
  647.    Next_Seq      := ( Seq_Num + 1 ) MOD 10;
  648.  
  649.    Errors        := 0;
  650.    Action        := R_Get_DLE;
  651.    Total_Packets := Total_Packets + 1;
  652.  
  653.                                    (* Get next packet *)
  654.    WHILE ( NOT Halt_Transfer ) DO
  655.       BEGIN
  656.  
  657.          Check_KeyBoard;
  658.  
  659.          Timer := 10;
  660.  
  661.          CASE Action OF
  662.  
  663.             R_Get_DLE: BEGIN
  664.  
  665.                           IF ( NOT Read_Byte ) THEN
  666.                              Action := R_Send_NAK
  667.                           ELSE IF ( ( Ch AND $7F ) = dle ) THEN
  668.                              Action := R_Get_b
  669.                           ELSE IF ( ( Ch AND $7F ) = ENQ ) THEN
  670.                              Action := R_Send_ACK;
  671.                        END;
  672.  
  673.             R_Get_b:   BEGIN
  674.  
  675.                           IF ( NOT Read_Byte ) THEN
  676.                              Action := R_Send_NAK
  677.                           ELSE IF ( ( Ch AND $7F ) = ORD('B') ) THEN
  678.                              Action := R_Get_seq
  679.                           ELSE IF ( Ch = ENQ ) THEN
  680.                              Action := R_Send_ACK
  681.                           ELSE
  682.                              Action := R_Get_DLE;
  683.                        END;
  684.  
  685.             R_Get_seq: BEGIN
  686.  
  687.                           IF ( NOT Read_Byte ) THEN
  688.                              Action := R_Send_NAK
  689.                           ELSE IF ( Ch = ENQ ) THEN
  690.                              Action := R_Send_ACK
  691.                           ELSE
  692.                              BEGIN
  693.                                 CheckSum  := 0;
  694.                                 Block_Num := Ch - ORD('0');
  695.                                 Do_Checksum( Ch );
  696.                                 i      := 0;
  697.                                 Action := R_Get_data;
  698.                              END;
  699.  
  700.                        END;
  701.  
  702.            R_Get_data: BEGIN
  703.  
  704.                           IF ( NOT Read_Masked_Byte ) THEN
  705.                              Action := R_Send_NAK
  706.                           ELSE IF ( ( Ch = etx ) AND ( NOT Masked ) ) THEN
  707.                              BEGIN
  708.                                 Do_Checksum( etx );
  709.                                 Action := R_Get_CheckSum;
  710.                              END
  711.                           ELSE
  712.                              BEGIN
  713.                                 R_Buffer[i] := Ch;
  714.                                 i           := i + 1;
  715.                                 Do_Checksum( Ch );
  716.                              END;
  717.  
  718.                        END;
  719.  
  720.        R_Get_CheckSum: BEGIN
  721.  
  722.                           IF ( NOT Read_Masked_Byte ) THEN
  723.                              Action := R_Send_NAK
  724.                           ELSE IF ( Ch <> CheckSum ) THEN
  725.                              Action := R_Send_NAK
  726.                           ELSE IF ( Block_Num = Seq_Num ) THEN
  727.                              BEGIN
  728.                                 IF ( R_Buffer[0] = ORD('F') ) THEN
  729.                                    BEGIN
  730.                                       Seq_Num     := Block_Num;
  731.                                       R_Size      := i;
  732.                                       Read_Packet :=  TRUE;
  733.                                       EXIT;
  734.                                    END
  735.                                 ELSE
  736.                                    Action := R_Send_ACK;
  737.                              END
  738.                           ELSE IF ( Block_Num <> Next_Seq ) THEN
  739.                              Action := R_Send_NAK
  740.                           ELSE
  741.                              BEGIN
  742.                                 Seq_Num     := Block_Num;
  743.                                 R_Size      := i;
  744.                                 Read_Packet := TRUE;
  745.                                 EXIT;
  746.                              END;
  747.  
  748.                        END;
  749.  
  750.            R_Send_NAK: BEGIN
  751.  
  752.                           Errors       := Errors + 1;
  753.                           Total_Errors := Total_Errors + 1;
  754.  
  755.                           IF ( Errors > Max_Errors ) THEN
  756.                              BEGIN
  757.                                 Read_Packet := FALSE;
  758.                                 EXIT;
  759.                              end;
  760.  
  761.                           Send_NAK;
  762.  
  763.                           Action := R_Get_DLE;
  764.  
  765.                        END;
  766.  
  767.            R_Send_ACK: BEGIN
  768.                                    (* wait for the next block *)
  769.  
  770.                           Send_ACK;
  771.                           Action := R_Get_DLE;
  772.  
  773.                        END;
  774.  
  775.           END (* CASE *);
  776.  
  777.    END (* WHILE *);
  778.  
  779. END    (* Read_Packet *);
  780.  
  781. (*----------------------------------------------------------------------*)
  782.  
  783. FUNCTION Write_File( VAR Data_File : INTEGER;
  784.                          R_Buffer  : BufferType;
  785.                          n         : INTEGER;
  786.                          size      : INTEGER) : INTEGER;
  787.  
  788. BEGIN (* Write_File *)
  789.  
  790.    Write_File := Write_File_Handle( Data_File, R_Buffer[ n ], size );
  791.  
  792. END   (* Write_File *);
  793.  
  794. (*----------------------------------------------------------------------*)
  795.  
  796. FUNCTION Receive_File( Name : AnyStr ) : BOOLEAN;
  797.  
  798. VAR
  799.    Data_File : INTEGER;
  800.    Status    : INTEGER;
  801.    R_File    : BOOLEAN;
  802.  
  803. BEGIN (* Receive_File *)
  804.                                    (* Assume transfer fails   *)
  805.    R_File := FALSE;
  806.                                    (* Open file to be created *)
  807.  
  808.    Status := Create_File_Handle( Name, Attribute_None, Data_File );
  809.  
  810.                                    (* Halt transfer if file can't be *)
  811.                                    (* opened.                        *)
  812.    IF ( Status <> 0 ) THEN
  813.       BEGIN
  814.          Send_Failure('E');
  815.          GoToXY( 22 , Err_Mess_Line );
  816.          WRITE('Can''t open output file, transfer stoppped.');
  817.          ClrEol;
  818.          Receive_File := FALSE;
  819.          EXIT;
  820.       END;
  821.                                    (* Send ACK to start transfer  *)
  822.    Send_ACK;
  823.                                    (* Begin loop over packets *)
  824.  
  825.    WHILE ( NOT ( Halt_Transfer OR R_File  ) ) DO
  826.       BEGIN
  827.                                    (* Get next packet *)
  828.          IF Read_Packet THEN
  829.             BEGIN
  830.                                    (* Select Action based upon packet type *)
  831.  
  832.                CASE CHR( R_Buffer[0] ) OF
  833.  
  834.                                    (* Data for file -- write it and *)
  835.                                    (* acknowledge it.               *)
  836.                   'N': BEGIN
  837.                           Status := Write_File( Data_File, R_Buffer, 1,
  838.                                                 R_Size - 1 );
  839.                           Send_ACK;
  840.                           Total_Blocks := Total_Blocks + 1;
  841.                        END;
  842.                                    (* End of transfer -- close file *)
  843.                                    (* and acknowledge end of file   *)
  844.                   'T': BEGIN
  845.  
  846.                           IF ( R_Buffer[1] = ORD('C') ) THEN
  847.                              BEGIN
  848.                                 GoToXY( 22 , Err_Mess_Line );
  849.                                 WRITE('Transfer Complete');
  850.                                 ClrEol;
  851.                                 Status := Close_File_Handle( Data_File );
  852.                                 Send_ACK;
  853.                                 R_File  := TRUE;
  854.                                 DELAY( Two_Second_Delay );
  855.                              END;
  856.  
  857.                        END;
  858.                                    (* Stop transfer received -- halt *)
  859.                                    (* transfer and acknowledge.      *)
  860.                   'F': BEGIN
  861.                           Send_ACK;
  862.                           Halt_Transfer := TRUE;
  863.                           GoToXY( 22 , Err_Mess_Line );
  864.                           WRITE('Host cancelled transfer.');
  865.                           ClrEol;
  866.                           DELAY( Two_Second_Delay );
  867.                        END;
  868.  
  869.                 END   (* CASE *);
  870.  
  871.             END  (* IF *);
  872.                                    (* Check for keyboard input halting *)
  873.                                    (* transfer.                        *)
  874.          Check_Keyboard;
  875.  
  876.          IF Halt_Transfer THEN
  877.             BEGIN
  878.                Send_Failure('E');
  879.                GoToXY( 22 , Err_Mess_Line );
  880.                WRITE('ESC key hit -- transfer terminated.');
  881.                ClrEol;
  882.             END;
  883.  
  884.       END  (* WHILE *);
  885.  
  886.    Receive_File := R_File;
  887.  
  888.    Status       := Close_File_Handle( Data_File );
  889.  
  890. END   (* Receive_File *);
  891.  
  892. (*--------------- CompuServe_B_Transfer --- main code -------------------*)
  893.  
  894. BEGIN (* Do_CompuServe_B_Transfer *)
  895.  
  896.                                    (* Reset comm parms to 8,n,1 *)
  897.  
  898.    Xmodem_Bits_Save   := Data_Bits;
  899.    Xmodem_Parity_Save := Parity;
  900.    Xmodem_Stop_Save   := Stop_Bits;
  901.  
  902.    Async_Reset_Port( Comm_Port, Baud_Rate, 'N', 8, 1 );
  903.  
  904.                                    (* Announce protocol starts *)
  905.    Save_Screen( Saved_Screen );
  906.  
  907.    Draw_Menu_Frame( 5, 10, 75, 16, Menu_Frame_Color,
  908.                     Menu_Text_Color, 'CompuServe B Protocol' );
  909.  
  910.    GoToXY( 1 , 1 );
  911.    WRITE('Blocks transferred:  ');
  912.  
  913.    GoToXY( 1 , 2 );
  914.    WRITE('Packets transferred: ');
  915.  
  916.    GoToXY( 1 , 3 );
  917.    WRITE('Total errors:        ');
  918.  
  919.    GoTOXY( 1 , Err_Mess_Line );
  920.    WRITE('Last status message: ');
  921.  
  922.                                    (* Assume transfer goes OK *)
  923.  
  924.    Do_CompuServe_B_Transfer := TRUE;
  925.  
  926.    Halt_Transfer := FALSE;
  927.    Xoff_Flag     := FALSE;
  928.    Seq_Num       := 0;
  929.    Comp_Title    := 'CIS B -- ';
  930.    Total_Blocks  := 0;
  931.    Total_Packets := 0;
  932.    Total_Errors  := 0;
  933.                                    (* ACKnowledge start of protocol *)
  934.    Send_ACK;
  935.                                    (* Read initial packet *)
  936.    IF Read_Packet THEN
  937.       BEGIN
  938.                                    (* Select Action based upon packet type *)
  939.  
  940.          CASE CHR( R_Buffer[0] ) OF
  941.  
  942.                                    (* Upload or download *)
  943.             'T': BEGIN
  944.  
  945.                     CASE CHR( R_Buffer[1] ) OF
  946.                        'D' : Comp_Title := 'Receiving ';
  947.                        'U' : Comp_Title := 'Sending ';
  948.                        ELSE
  949.                              BEGIN
  950.                                 Send_Failure('N');
  951.                                 Do_CompuServe_B_Transfer := FALSE;
  952.                                 EXIT;
  953.                              END;
  954.                     END  (* CASE *);
  955.  
  956.                                    (* Get file name *)
  957.  
  958.                     CASE CHR( R_Buffer[2] ) OF
  959.                        'A': Comp_Title := Comp_Title + 'ASCII file "';
  960.                        'B': Comp_Title := Comp_Title + 'Binary file "';
  961.                        ELSE
  962.                           BEGIN
  963.                              Send_Failure('N');        (* Not implemented *)
  964.                              Do_CompuServe_B_Transfer := FALSE;
  965.                              EXIT;
  966.                           END;
  967.                     END   (* CASE *);
  968.  
  969.                     i        := 2;
  970.                     FileName := '';
  971.  
  972.                     WHILE ( R_Buffer[i] <> 0 ) AND ( i < R_Size ) DO
  973.                        BEGIN
  974.                           i        := i + 1;
  975.                           FileName := FileName + CHR( R_Buffer[i] );
  976.                        END;
  977.  
  978.                     Comp_Title := Comp_Title + FileName + '"';
  979.  
  980.                                    (* Display file transfer header *)
  981.  
  982.                     Draw_Menu_Frame( 5, 10, 75, 16, Menu_Frame_Color,
  983.                                      Menu_Text_Color, Comp_Title );
  984.  
  985.                     GoToXY( 1 , 1 );
  986.                     WRITE('Blocks transferred:  ');
  987.  
  988.                     GoToXY( 1 , 2 );
  989.                     WRITE('Packets transferred: ');
  990.  
  991.                     GoToXY( 1 , 3 );
  992.                     WRITE('Total errors:        ');
  993.  
  994.                     GoTOXY( 1 , Err_Mess_Line );
  995.                     WRITE('Last status message: ');
  996.  
  997.                                    (* Perform transfer *)
  998.  
  999.                     IF ( R_Buffer[1] = ORD('U') ) THEN
  1000.                        Dummy := Send_File( FileName )
  1001.                     ELSE
  1002.                        Dummy := Receive_File( FileName );
  1003.  
  1004.                  END;
  1005.  
  1006.          END (* CASE *);
  1007.  
  1008.       END (* IF *)
  1009.                                    (* No initial packet -- quit *)
  1010.     ELSE
  1011.        BEGIN
  1012.           GoToXY( 22 , Err_Mess_Line );
  1013.           WRITE('Cannot receive initial packet, transfer aborted');
  1014.           ClrEol;
  1015.           DELAY( Two_Second_Delay );
  1016.        END;
  1017.                                    (* Restore previous screen *)
  1018.  
  1019.    Restore_Screen( Saved_Screen );
  1020.    Reset_Global_Colors;
  1021.                                    (* Reset comm parms back *)
  1022.  
  1023.    Async_Reset_Port( Comm_Port, Baud_Rate, Xmodem_Parity_Save,
  1024.                      Xmodem_Bits_Save, Xmodem_Stop_Save );
  1025.  
  1026. END   (* Do_CompuServe_B_Transfer *);
  1027.